;;;============================================================================
;;;
;;; Subject: Suspensions2
;;;         
;;;
;;;----------------------------------------------------------------------------
;;;
;;; Author: Jónathan Heras Vicente  
;;; 13/10/09
;;;
;;;============================================================================

(IN-PACKAGE "COMMON-LISP-USER")

(provide "suspension2")

(DEFUN suspension2-basis (basis)
  (declare (type basis basis))
  (when (eq basis :locally-effective)
    (return-from suspension2-basis :locally-effective))
  (flet ((rslt (degr)
	   (declare (fixnum degr))
	   (funcall basis (1- degr))))
    (the basis #'rslt)))

#|
  (setf cc (sphere 2))
  (setf basis (suspension2-basis (basis cc)))
  (dotimes (i 6)
    (print (funcall basis i)))
  (suspension-basis :locally-effective)
|#

(defun suspension2-intr-dffr (dffr)
  (declare (type morphism dffr))
  (flet ((rslt (cmbn)
	   (declare (type cmbn cmbn))
               (with-cmbn (degr list) cmbn
                 (if (> degr 0)
                     (let ((cmbn-bis (make-cmbn :degr (1- degr) :list list)))
                       (make-cmbn :degr (1- degr)
                                  :list (mapcar #'(lambda (old)
                                                    (term (* -1 (cffc old))
                                                          (gnrt old))
                                                    )
                                          (cmbn-list (? dffr cmbn-bis)) )
                                  ))
                   (zero-cmbn (1- degr))))))
    (the intr-mrph #'rslt))  
  )

#|
  (setf cc (deltab))
  (setf intr (suspension2-intr-dffr (dffr cc)))
  (funcall intr (cmbn 3 66 7))
|#


(DEFMETHOD SUSPENSION2 ((chcm chain-complex))
  (the chain-complex
    (with-slots (cmpr basis dffr) chcm
      (build-chcm
       :cmpr cmpr
       :basis (suspension2-basis basis)
       :bsgn nil
       :intr-dffr (suspension2-intr-dffr dffr)
       :strt :cmbn
       :orgn `(suspension2 ,chcm)))))



#|
  (cat-init)
  (setf cc (deltab))
  (setf scc (suspension2 cc))
  (cmpr scc 7 11)
  (basis scc 3)  ;; error
  (bsgn scc)
  (? scc 3 11)
|#


(DEFUN SUSPENSION2-INTR (mrph)
  (declare (type morphism mrph))
  (flet ((rslt (cmbn)
               (declare (type cmbn cmbn))
               (with-cmbn (degr list) cmbn
                 (make-cmbn :degr (+ degr (degr mrph))
                            :list (mapcar #'(lambda (old)
                                     (term (* -1 (cffc old))
                                           (gnrt old))
                                     )
                           (cmbn-list
				 (? mrph (make-cmbn :degr (1- degr)
							 :list list))) )
                            ))))
    (the intr-mrph #'rslt)))

#|
  (setf f (idnt-mrph (deltab)))
  (setf sf (suspension2-intr f))
  (funcall sf (cmbn 2 4 3))
  (setf d (dffr (deltab)))
  (setf sd (suspension2-intr d))
  (funcall sd (cmbn 2 4 3))
  (funcall sd (cmbn 3 4 7))
|#



(DEFMETHOD SUSPENSION2 ((mrph morphism))
  (the morphism
    (let ((orgn (orgn mrph)))
      (declare (list orgn))
      (when (eq (first orgn) 'zero-mrph)
	(return-from suspension2
	  (zero-mrph (suspension2 (sorc mrph))
		     (suspension2 (trgt mrph))
		     (degr mrph))))
      (when (eq (first orgn) 'idnt-mrph)
	(return-from suspension2
	  (idnt-mrph (suspension2 (sorc mrph)))))
      (build-mrph
       :sorc (suspension2 (sorc mrph))
       :trgt (suspension2 (trgt mrph))
       :degr (degr mrph)
       :intr (suspension2-intr mrph)
       :strt :cmbn
       :orgn `(suspension2 ,mrph)))))

#|
  (setf f (idnt-mrph (deltab)))
  (setf sf (suspension2 f))
  (? sf (cmbn 2 4 3))
  (setf d (dffr (deltab)))
  (setf sd (suspension2 d))
  (? sd (cmbn 2 4 3))
  (? sd (cmbn 3 4 7))
|#


(DEFMETHOD SUSPENSION2 ((rdct reduction))
  (the reduction (progn
    (when (eq (first (orgn rdct)) 'trivial-rdct)
      (return-from suspension2
	(trivial-rdct (suspension2 (second (orgn rdct))))))
    (build-rdct
      :f (suspension2 (f rdct))
      :g (suspension2 (g rdct))
      :h (suspension2 (h rdct))
     :orgn `(suspension2 ,rdct)))))


(DEFMETHOD SUSPENSION2 ((hmeq homotopy-equivalence))
  (the homotopy-equivalence (progn
    (when (eq (first (orgn hmeq)) 'trivial-hmeq)
      (return-from suspension2
	(trivial-hmeq (suspension2 (second (orgn hmeq))))))
    (build-hmeq
      :lrdct (suspension2 (lrdct hmeq))
      :rrdct (suspension2 (rrdct hmeq))
     :orgn `(suspension2 ,hmeq)))))



#|

(cat-init)
(setf s3xs3 (crts-prdc (sphere 3) (sphere 3)))
(setf s3xs3-efhm (efhm s3xs3))
(setf s_2-s3xs3-efhm (suspension2 s3xs3-efhm))
(setf lrdct (lrdct s_2-s3xs3-efhm))

(pre-check-rdct lrdct)
(setf *tc* (cmbn 3 1 (first (basis (k 38) 3)) -2 (second (basis (k 38) 3))))
(setf *bc* (cmbn 4 -1 (first (basis (k 40) 4)) -5 (second (basis (k 40) 4)) 7 (third (basis (k 40) 4))))
(check-rdct)

(setf rrdct (rrdct s_2-s3xs3-efhm))

(pre-check-rdct rrdct)
(setf *tc* (cmbn 3 1 (first (basis (k 38) 3)) -2 (second (basis (k 38) 3))))
(setf *bc* (cmbn 4 -1 (first (basis (k 46) 4)) -5 (second (basis (k 46) 4))))
(check-rdct)

|#

(DEFMETHOD SEARCH-EFHM (suspension2 (orgn (eql 'suspension2)))
  (declare (type chain-complex suspension2))
  (suspension2 (efhm (second (orgn suspension2)))))

#|
  (setf sk (suspension2 (k-z 2)))
  (homology sk 0 10)
|#




